home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FORTRAN1.LZH / GETOKE.FOR < prev    next >
Text File  |  1988-02-08  |  6KB  |  233 lines
  1.       SUBROUTINE GETOKE ( LINE, LEN, IPTR, TOKEN, TYPE, ERROR )
  2. C*
  3. C*                  *******************************
  4. C*                  *******************************
  5. C*                  **                           **
  6. C*                  **          GETOKE           **
  7. C*                  **                           **
  8. C*                  *******************************
  9. C*                  *******************************
  10. C*
  11. C*     SUBPROGRAM :
  12. C*          GET TOKEN
  13. C*
  14. C*     AUTHOR :
  15. C*          ART RAGOSTA
  16. C*          MS 207-5
  17. C*          AMES RESEARCH CENTER
  18. C*          MOFFETT FIELD, CA  94035
  19. C*          (415) 694-5578
  20. C*
  21. C*     PURPOSE :
  22. C*          EXTRACT THE NEXT TOKEN FROM A CHARACTER STRING USING
  23. C*          THE FOLLOWING CONVENTIONS :
  24. C*               1. MORE THAN ONE CONSECUTIVE SPACE IS TREATED AS A
  25. C*                   SINGLE SPACE.
  26. C*               2. TWO CONSECUTIVE DELIMITERS RETURN A NULL TOKEN.
  27. C*               3. WORDS MUST BEGIN WITH A CHARACTER.
  28. C*               4. NUMBERS MUST BEGIN WITH A DIGIT.
  29. C*               5. ALL OTHER CHARACTERS ARE RETURNED VERBATIM.
  30. C*               6. VALID DELIMITERS ARE  , ; : AND <SPACE>.
  31. C*
  32. C*     INPUT ARGUMENTS :
  33. C*          LINE - THE LINE TO BE PARSED.
  34. C*          LEN  - THE LAST CHARACTER TO SCAN IN LINE.
  35. C*          IPTR - THE LOCATION FROM WHICH PARSING IS TO BEGIN.
  36. C*
  37. C*     OUTPUT ARGUMENTS :
  38. C*          IPTR  - THE LAST CHARACTER IN LINE THAT WAS SCANNED.
  39. C*          TOKEN - THE CHARACTER *20 RESULT.
  40. C*          ERROR - AN ERROR OCCURRED IN PARSING THE LINE.
  41. C*
  42. C*     INTERNAL WORK AREAS :
  43. C*          NONE
  44. C*
  45. C*     COMMON BLOCKS :
  46. C*          NONE
  47. C*
  48. C*     FILE REFERENCES :
  49. C*          NONE
  50. C*
  51. C*     DATA BASE ACCESS :
  52. C*          NONE
  53. C*
  54. C*     SUBPROGRAM REFERENCES :
  55. C*          NONE
  56. C*
  57. C*     ERROR PROCESSING :
  58. C*          NONE
  59. C*
  60. C*     TRANSPORTABILITY LIMITATIONS :
  61. C*          NONE
  62. C*
  63. C*     ASSUMPTIONS AND RESTRICTIONS :
  64. C*          NONE
  65. C*
  66. C*     LANGUAGE AND COMPILER :
  67. C*          ANSI FORTRAN 77
  68. C*
  69. C*     VERSION AND DATE :
  70. C*          VERSION I.0      3-OCT-84
  71. C*
  72. C*     CHANGE HISTORY :
  73. C*           3-OCT-84    INITIAL VERSION
  74. C*
  75. C***********************************************************************
  76. C*
  77.       CHARACTER *(*) LINE
  78.       CHARACTER *20 TOKEN
  79.       CHARACTER *1 EOL,CH,TYPE
  80.       INTEGER TSIZE
  81.       LOGICAL ERROR
  82. C
  83. C --- END OF LINE INDICATOR
  84. C
  85.       EOL = CHAR(13)
  86. C
  87. C --- SKIP LEADING BLANKS
  88. C
  89.       IF ( IPTR .LT. 1 ) IPTR = 1
  90.       CH = LINE(IPTR:IPTR)
  91. C
  92. C --- WHILE CH = ' ' DO GETCH
  93. C
  94. 10    IF ( CH .NE. ' ' ) GO TO 20
  95.       IPTR = IPTR + 1
  96.       IF ( IPTR .GT. LEN ) THEN
  97.          CH = EOL
  98.          GO TO 20
  99.       ENDIF
  100.       CH = LINE(IPTR:IPTR)
  101.       GO TO 10
  102. C
  103. C --- END WHILE CH = ' '
  104. C
  105. C --- IF CHARACTER IS DELIMITER, RETURN A NULL VALUE
  106. C
  107. 20    TOKEN = ' '
  108.       IF ((CH .EQ. ',') .OR. (CH .EQ. ';') .OR. (CH .EQ. ':')
  109.      $  .OR. (CH .EQ. EOL)) THEN
  110. C
  111. C ----- FIRST CHARACTER WAS A DELIMITER... RETURN A NULL VALUE
  112. C
  113.          TYPE  = 'N'
  114.          IF ( CH .NE. EOL ) THEN
  115.             IPTR = IPTR + 1
  116.          ELSE
  117.             TYPE = 'E'
  118.          ENDIF
  119.       ELSE
  120. C
  121. C --- FIRST CHARACTER WAS NOT A DELIMITER
  122. C
  123.          IF ((CH .GE. 'A') .AND. (CH .LE. 'Z')) THEN
  124. C
  125. C ----- ALPHABETIC TOKEN
  126. C
  127.             TYPE = 'A'
  128. C
  129. C -------     WHILE (CH IN ALPHA+DIGITS) PACK CHARACTERS INTO TOKEN
  130. C
  131.             TSIZE = 1
  132. 30          IF (TSIZE .LE. 20) TOKEN(TSIZE:TSIZE) = CH
  133.             TSIZE = TSIZE + 1
  134.             IPTR = IPTR + 1
  135.             IF ( IPTR .GT. LEN ) THEN
  136.                CH = EOL
  137.             ELSE
  138.                CH = LINE(IPTR:IPTR)
  139.             ENDIF
  140.             IF (((CH .GE. 'A') .AND. (CH .LE. 'Z')) .OR.
  141.      $       ((CH .GE. '0') .AND. (CH .LE. '9'))) GO TO 30
  142. C
  143. C ----- END WHILE (CH IN ALPHA+DIGITS)
  144. C
  145.          ELSE IF (((CH .GE. '0') .AND. (CH .LE. '9')) .OR.
  146.      $            (CH .EQ. '+') .OR. (CH .EQ. '-')) THEN
  147. C
  148. C ----- NUMERICAL TYPE... DEFAULT TO INTEGER
  149. C
  150.             TYPE = 'I'
  151.             TSIZE = 1
  152.             IF ((CH .EQ. '-') .OR. (CH .EQ. '+')) THEN
  153.                TOKEN(TSIZE:TSIZE) = CH
  154.                IPTR = IPTR + 1
  155.                CH = LINE(IPTR:IPTR)
  156.                IF ((CH .NE. '.') .AND.
  157.      $            ((CH .LT. '0') .OR. (CH .GT. '9'))) THEN
  158.                   IPTR = IPTR - 1
  159.                   TYPE = 'S'
  160.                   RETURN
  161.                ENDIF
  162.                TSIZE = TSIZE + 1
  163.             ENDIF
  164. C
  165. C ------ WHILE (CH IN DIGITS+'E'+'.') PACK CHARACTERS INTO TOKEN
  166. C
  167. 40          IF (TSIZE .LE. 20) TOKEN(TSIZE:TSIZE) = CH
  168.             TSIZE = TSIZE + 1
  169.             IPTR = IPTR + 1
  170.             IF ( IPTR .GT. LEN ) THEN
  171.                CH = EOL
  172.             ELSE
  173.                CH = LINE(IPTR:IPTR)
  174.             ENDIF
  175.             IF ((CH .GE. '0') .AND. (CH .LE. '9')) GO TO 40
  176. C
  177. C -------- EITHER '.' OR 'E' INDICATE A REAL NUMBER
  178. C
  179.             IF (CH .EQ. '.') THEN
  180.                TYPE = 'R'
  181.                GO TO 40
  182.             ENDIF
  183.             IF (CH .EQ. 'E') THEN
  184. C
  185. C ----------- EXPONENT FOUND
  186. C
  187.                TYPE = 'R'
  188. 50             IF (TSIZE .LE. 20) TOKEN(TSIZE:TSIZE) = CH
  189.                TSIZE = TSIZE + 1
  190.                IPTR = IPTR + 1
  191.                IF ( IPTR .GT. LEN ) THEN
  192.                   CH = EOL
  193.                ELSE
  194.                   CH = LINE(IPTR:IPTR)
  195.                ENDIF
  196. C
  197. C ------------ '+' AND '-' PERMITTED AS FIRST CHARACTER IN EXPONENT
  198. C
  199.                IF ((CH .EQ. '+') .OR. (CH .EQ. '-')) THEN
  200.                   GO TO 50
  201.                ELSE
  202.                   GO TO 40
  203.                ENDIF
  204.             ENDIF
  205. C
  206. C ------ END WHILE (CH IN DIGITS+'E'+'.')
  207. C
  208. C ------ OTHERWISE, RETURN THE SPECIAL CHARACTER ONLY
  209. C
  210.          ELSE
  211.             TYPE = 'S'
  212.             TOKEN(1:1) = CH
  213.          ENDIF
  214.       ENDIF
  215. C
  216. C --- SKIP THE DELIMITER
  217. C
  218. 60    IF ( CH .NE. ' ' ) GO TO 70
  219.       IPTR = IPTR + 1
  220.       IF ( IPTR .GT. LEN ) THEN
  221.          CH = EOL
  222.          GO TO 70
  223.       ENDIF
  224.       CH = LINE(IPTR:IPTR)
  225.       GO TO 60
  226. 70    IF ((CH .EQ. ',') .OR. (CH .EQ. ';') .OR. (CH .EQ. ':'))
  227.      $ IPTR = IPTR + 1
  228.       RETURN
  229.       END
  230. C
  231. C---END GETOKE
  232. C
  233.